home *** CD-ROM | disk | FTP | other *** search
/ TPUG - Toronto PET Users Group / TPUG Users Group CD / TPUG Users Group CD.iso / AMIGA / AMICUS / AMICUS15.ADF / AmigaBasicProgs / Light < prev    next >
Text File  |  1988-04-20  |  10KB  |  636 lines
  1. 'Light
  2. 'by ronald s. hill
  3. '
  4. 'np = number of players
  5. 'pn = player number
  6. 'mp = maximum players
  7. 'ms = maximum score
  8. 'i  = input
  9. 'x  = temporary variables
  10. 'px = termpory x position
  11. 'py = temporary y position
  12. 'md() = move direction values
  13. 'wx = size window x
  14. 'wy = size window y
  15. 'sc = maximum score
  16. 'nt = newly terminated?
  17. 'sa = snakes active -1 is yes
  18. 'mo = menu on ?
  19. 'so = snake menu on ?
  20. 'fr = starting frequency
  21.  
  22. 'pc() = players color
  23. 'pd() = players device
  24. 'ph() = players heading
  25. 'pn$() = players name
  26. 'px() = players x position
  27. 'py() = players y position
  28. 'ps() = players score
  29. 'ok() = player alive? -1 is yes
  30. 'pt() = player terminated 0 alive -1 dead -2 out of round 1 out of game
  31. 'sx(pn,sp) = snake x position
  32. 'sy(pn,sp) = snake y position
  33. 'ss() = snake size
  34. 'sf() = snake full 0 is false
  35. 'sp() = snake position
  36. 'sa() = snake active 0 not snake
  37.  
  38. setup:
  39.  
  40. SCREEN 1,320,200,4,1
  41.  WINDOW CLOSE 1
  42. WINDOW 2,"Light......",(8,12)-(288,184),1+2+16,1
  43. PALETTE 0,0,0,0
  44. PALETTE 1,1,1,1
  45. PALETTE 2,1,0,0
  46. PALETTE 3,1,0,0
  47. PALETTE 4,0,1,0
  48. PALETTE 5,0,0,1
  49. COLOR 1,0
  50. CLS
  51. PRINT "Light"
  52. PRINT "Version 1.0"
  53. PRINT "by Ronald S. Hill"
  54. PRINT
  55. PRINT "Use Menus to Change options"
  56. 'PRINT "Ctrl-C to return to basic"
  57.  
  58.  
  59. menup:
  60. MENU 1,0,1,"Control"
  61. MENU 1,1,1,"Restart"
  62. MENU 1,2,1,"Load another program"
  63. MENU 1,3,1,"Exit to Basic"
  64. MENU 1,4,1,"Exit to Workbench"
  65.  
  66. MENU 2,0,1,"Option"
  67. MENU 2,1,1,"Score"
  68. MENU 2,2,1,"  Snakes"
  69. MENU 2,3,1,"> Bounce"
  70. MENU 2,4,1,"Info"
  71.  
  72. FOR pn=1 TO 4
  73. MENU 2+pn,0,1,RIGHT$(STR$(pn),1)
  74. MENU 2+pn,1,1,"Device"
  75.  
  76. MENU 2+pn,2,1,"Score"
  77. MENU 2+pn,3,1,"  Snake"
  78. NEXT pn
  79.  
  80. ON MENU GOSUB menus
  81.  
  82. ON BREAK GOSUB abort 'done
  83. MENU ON
  84. BREAK ON
  85.  
  86. CLEAR
  87. DEFINT A-Z
  88. OPTION BASE 1
  89. mp=4
  90. DIM dp(4),pd(4),ph(mp),pn$(mp),px(mp),py(mp),pt(mp),pc(mp),ps(mp)
  91. DIM dn$(7),mx(4),my(4)
  92. DIM sx(4,100),sy(4,100)
  93. DIM ss(4),sf(4),sp(4),sa(4)
  94. pc(1)=3
  95. pc(2)=4
  96. pc(3)=5
  97. pc(4)=6
  98. 'dn$(1)="Joystick 1"
  99. dn$(2)="Joystick 2"
  100. dn$(3)="Cursor"
  101. 'dn$(4)="Mouse"
  102. dn$(4)="Random"
  103. 'dn$(6)="Computer - Easy"
  104. 'dn$(7)="Computer - Harder"
  105. mx(1)=0:my(1)=-1
  106. mx(2)=1:my(2)=0
  107. mx(3)=0:my(3)=1
  108. mx(4)=-1:my(4)=0
  109. bo = -1
  110. RANDOMIZE TIMER
  111.  
  112. GOSUB waits
  113.  
  114. questions:
  115. GOSUB smenuon
  116. pn=0
  117. np=0
  118. ok=-1
  119.  
  120. WHILE (ok)
  121.   pn=pn+1
  122.   GOSUB device
  123.   IF (pn=mp OR I$=" ") AND pn<> 1 THEN ok=0
  124. WEND
  125. sc=10
  126. IF pn<4  THEN np=pn-1 ELSE np=4
  127. IF pn=4 AND I$=" " THEN np=3
  128.  
  129.  
  130. restart:
  131. GOSUB smenuon
  132. FOR pn = 1 TO np
  133.   ps(pn)=0
  134. NEXT pn
  135. fm=-1
  136. WHILE(ps(1)<sc AND ps(2)<sc AND ps(3)<sc AND ps(4)<sc)
  137. CLS
  138. PALETTE 0,0,0,0
  139. PALETTE 1,1,1,1
  140. PALETTE 2,1,0,0
  141. PALETTE 3,1,0,0
  142. PALETTE 4,0,1,0
  143. PALETTE 5,0,0,1
  144. PALETTE 6,1,1,1
  145. COLOR 1,0
  146. CLS
  147.  
  148. wx=WINDOW(2)
  149. wy=WINDOW(3)
  150.  
  151. px(1)=INT(wx/3)
  152. py(1)=INT(wy/2)
  153. px(2)=INT(wx*.6666)
  154. py(2)=INT(wy/2)
  155. px(3)=INT(wx/2)
  156. py(3)=INT(wy/3)
  157. px(4)=INT(wx/2)
  158. py(4)=INT(wy*.6666)
  159.  
  160. IF fm=-1 THEN
  161.   fm=0
  162.   ox=1
  163.   oy=1
  164.   py = py(1)
  165.   FOR px=1 TO px(1)
  166.     PSET(px,py),pc(1)
  167.     PSET(ox,oy),0
  168.     ox=px
  169.     oy=py
  170.   NEXT px
  171.   IF np>1 THEN
  172.     ox=1
  173.     oy=1
  174.     py=py(2)
  175.     FOR px=wx TO px(2) STEP -1
  176.       PSET(px,py),pc(2)
  177.       PSET(ox,oy),0
  178.       ox=px
  179.       oy=py
  180.     NEXT px
  181.   END IF
  182.   IF np>2 THEN
  183.     ox=1
  184.     oy=1
  185.     px=px(3)
  186.     FOR py=1 TO py(3)
  187.       PSET(px,py),pc(3)
  188.       PSET(ox,oy),0
  189.       ox=px
  190.       oy=py
  191.     NEXT py
  192.   END IF
  193.   IF np>3 THEN
  194.     ox=1
  195.     oy=1
  196.     px=px(4)
  197.     FOR py=wy TO py(4) STEP -1
  198.       PSET(px,py),pc(4)
  199.       PSET(ox,oy),0
  200.       ox=px
  201.       oy=py
  202.     NEXT py
  203.   END IF
  204. END IF
  205.  
  206. FOR pn=1 TO np
  207.   IF pt<> -3 THEN pt(pn)=0
  208.   ph(pn)=1
  209.   PSET(px(pn),py(pn)),pc(pn)
  210. NEXT pn
  211. GOSUB waits
  212. GOSUB smenuoff
  213. sf=0
  214. FOR pn=1 TO np
  215.   sf(pn)=0
  216.   sp(pn)=1
  217. NEXT pn
  218. pt=0
  219. nt=0
  220. main:
  221. WHILE (pt<np-1)
  222.   IF sa THEN GOSUB dosnakes
  223.   FOR pn=1 TO np
  224.     IF pt(pn)=0 THEN
  225.     ph=ph(pn)
  226.     ON pd(pn) GOSUB joy1,joy2,cur,ran,ran,ran,ran
  227.     IF ABS(ph(pn)-ph)<>2 THEN ph(pn)=ph
  228.     px(pn)=px(pn)+mx(ph(pn))
  229.     py(pn)=py(pn)+my(ph(pn))
  230.     IF POINT(px(pn),py(pn))<>0 THEN
  231.       IF POINT(px(pn),py(pn))=-1 AND bo=-1 THEN
  232.         GOSUB dobounce
  233.       END IF
  234.       IF POINT(px(pn),py(pn))<>0 THEN
  235.         pt(pn)=-1
  236.         pt=pt+1
  237.         ot(pt)=pn
  238.         nt=nt+1
  239.       END IF
  240.     END IF
  241.  
  242.     PSET(px(pn),py(pn)),pc(pn)
  243.     END IF
  244.   NEXT pn
  245.   IF nt THEN GOSUB die:nt=0
  246. WEND
  247.  
  248.  
  249. roundend:
  250. GOSUB smenuon
  251. FOR pn = 1 TO np
  252.   IF pt(pn)= 0 THEN ps(pn)=ps(pn)+1
  253. NEXT pn
  254.  
  255. FOR pn=1 TO np
  256.   PRINT pn;" "pn$(pn);TAB(15);ps(pn);
  257.   IF ps(pn)=sc THEN PRINT " WINS";:ov=-1
  258.   PRINT
  259. NEXT pn
  260. GOSUB waits
  261.  
  262. fadeout:
  263.  
  264. IF ov = 0 THEN
  265. GOSUB fade1
  266. GOSUB fade2
  267. GOSUB fade3
  268. GOSUB fade4
  269.  
  270. END IF
  271.  
  272. WEND
  273.  
  274. PRINT
  275. PRINT "Press R to Restart"
  276. PRINT "      N for Newplayers"
  277.  
  278. getit:
  279. GOSUB in:
  280. IF I$="R" THEN GOTO restart
  281. IF I$="N" THEN GOTO questions
  282. GOTO getit
  283.  
  284. done:
  285.  
  286. GOSUB clean
  287. PRINT
  288. END
  289.  
  290. dosnakes:
  291. FOR pn = 1 TO np
  292.   IF sa(pn) AND pt(pn)=0 THEN
  293.     IF sp(pn)=ss(pn) THEN
  294.       sp(pn)=1
  295.       sf(pn)=-1
  296.     END IF
  297.     IF sf(pn) THEN
  298.        PSET(sx(pn,sp(pn)),sy(pn,sp(pn))),0
  299.     END IF
  300.     sx(pn,sp(pn))=px(pn)
  301.     sy(pn,sp(pn))=py(pn)
  302.     sp(pn)=sp(pn)+1
  303.   END IF
  304. NEXT pn
  305. RETURN
  306.  
  307. joy1:
  308. x=STICK(0)
  309. IF x<>0 THEN IF x=-1 THEN ph=4 ELSE ph=2
  310. x=STICK(1)
  311. IF x<>0 THEN IF x=-1 THEN ph=1 ELSE ph=3
  312. RETURN
  313.  
  314. joy2:
  315. x=STICK(2)
  316. IF x<>0 THEN IF x=-1 THEN ph=4 ELSE ph=2
  317. x=STICK(3)
  318. IF x<>0 THEN IF x=-1 THEN ph=1 ELSE ph=3
  319. RETURN
  320.  
  321. cur:
  322. I$=INKEY$
  323. I=0
  324. IF I$<>""THEN I=ASC(I$)
  325. IF I = 28 THEN ph=1:RETURN
  326. IF I = 30 THEN ph=2:RETURN
  327. IF I = 29 THEN ph=3:RETURN
  328. IF I = 31 THEN ph=4:RETURN
  329. RETURN
  330.  
  331. ran:
  332. IF INT(RND*15)=1 THEN ph=INT(RND*3)+1
  333. IF POINT(px(pn)+mx(ph),py(pn)+my(ph))<>0 THEN
  334.   xx=ph
  335.   ph=0
  336. loops:  ph = ph +1
  337.    IF ph=xx THEN GOTO loops
  338.    IF ph>4 THEN ph=ph(pn): GOTO loopend
  339.    IF POINT(px(pn)+mx(ph),py(pn)+my(ph))<>0 THEN GOTO loops
  340. loopend:
  341. END IF
  342. RETURN
  343.  
  344. die:
  345.  
  346. FOR tt = 1 TO 10
  347.   FOR cc = 1 TO 3
  348.   SOUND WAIT
  349.   SOUND 3000+cc*100,.3,127,0
  350.   SOUND 3000+cc*100,.3,127,1
  351.   SOUND RESUME
  352.   IF pt(1)=-1 THEN PALETTE pc(1),1-1/cc ,0,0
  353.   IF np>1 AND pt(2)=-1 THEN PALETTE pc(2),0,1-1/cc,0
  354.   IF np>2 AND pt(3)=-1 THEN PALETTE pc(3),0,0,1-1/cc
  355.   IF np>3 AND pt(4)=-1 THEN PALETTE pc(4),1-1/cc,1-1/cc,1-1/cc
  356.    FOR xx = 1 TO 20:NEXT xx
  357.   NEXT cc
  358. NEXT tt
  359.  
  360. FOR pn=1 TO np
  361.   IF pt(pn)=-1 THEN pt(pn)=-2
  362. NEXT pn
  363.  
  364. RETURN
  365.  
  366. dobounce:
  367. px(pn)=px(pn)-mx(ph(pn))
  368. py(pn)=py(pn)-my(ph(pn))
  369. oh=ph
  370. ph=0
  371. wloops:  ph = ph +1
  372. IF ph=oh THEN GOTO wloops
  373. IF ph>4 THEN ph(pn)=oh: GOTO wloopend
  374. IF POINT(px(pn)+mx(ph),py(pn)+my(ph))<>0 THEN GOTO wloops
  375. ph(pn)=ph
  376. wloopend: px(pn)=px(pn)+mx(ph(pn))
  377. py(pn)=py(pn)+my(ph(pn))
  378. BEEP
  379. RETURN
  380.  
  381. fade1:
  382. IF pt(1)<>-3 THEN
  383. FOR cc!=1 TO 0 STEP -.01
  384.   PALETTE pc(1),cc!,0,0
  385. NEXT cc!
  386. END IF
  387. RETURN
  388.  
  389. fade2:
  390. IF pt(2)<>-3 THEN
  391. FOR cc!=1 TO 0 STEP -.01
  392.   PALETTE pc(2),0,cc!,0
  393. NEXT cc!
  394. END IF
  395. RETURN
  396.  
  397. fade3:
  398. IF pt(3)<>-3 THEN
  399. FOR cc!=1 TO 0 STEP -.01
  400.   PALETTE pc(3),0,0,cc!
  401. NEXT cc!
  402. END IF
  403. RETURN
  404.  
  405. fade4:
  406. IF pt(4)<>-3 THEN
  407. FOR cc!=1 TO 0 STEP -.01
  408.   PALETTE pc(4),cc!,cc!,cc!
  409. NEXT cc!
  410. END IF
  411. RETURN
  412.  
  413. in:
  414. I$= UCASE$(INKEY$)
  415. IF I$ = "" THEN GOTO in
  416. RETURN
  417.  
  418. waits:
  419.  FOR tt=1 TO 10000:NEXT tt
  420. RETURN
  421.  
  422. clean:
  423. WINDOW 1
  424. SCREEN CLOSE 1
  425. MENU RESET
  426. 'x=MOUSE(1)
  427. RETURN
  428.  
  429. menus:
  430. m0=MENU(0)
  431. m1=MENU(1)
  432. ON m0 GOSUB con,opt,pla,pla,pla,pla
  433. RETURN
  434.  
  435. con:
  436. IF m1=1 THEN GOSUB clean:RUN
  437. GOSUB clean
  438. IF m1=2 THEN LOAD:END
  439. IF m1=3 THEN END
  440. IF m1=4 THEN SYSTEM
  441. RETURN
  442.  
  443. opt:
  444.  
  445. IF m1=1 THEN GOSUB scores
  446. IF m1=2 THEN GOSUB snakes
  447. IF m1=3 THEN GOSUB bounce
  448. IF m1=4 THEN GOSUB info
  449. RETURN
  450.  
  451. scores:
  452. GOSUB open3
  453. CLS
  454. COLOR 1,0
  455. PRINT
  456. INPUT "Maximum Score:",sc
  457. CLS
  458. GOSUB close3
  459. RETURN
  460.  
  461. snakes:
  462. IF so = 0 THEN BEEP:RETURN
  463. IF sa THEN
  464.   sa=0
  465.   ss=0
  466.   MENU 2,2,1,"  Snakes"
  467.   FOR mt = 1 TO 4
  468.     sa(mt)=0
  469.     ss(mt)=0
  470.     MENU 2+pn,3,1,"  Snake"
  471.   NEXT mt
  472. ELSE
  473.   GOSUB open3
  474.   CLS
  475.   COLOR 1,0
  476.   PRINT
  477.   PRINT "This option sets or"
  478.   PRINT "clears ALL players"
  479.   PRINT "as snakes."
  480.   PRINT
  481.   PRINT "Default is 200"
  482.   INPUT "Length of Snakes:",ss
  483.   IF ss=0 THEN ss=200
  484.   sa=-1
  485.   MENU 2,2,1,"> Snakes"
  486.   FOR mt = 1 TO 4
  487.     ss(mt)=ss
  488.     sa(mt)=-1
  489.     MENU 2+mt,3,1,"> Snake"
  490.   NEXT mt
  491.   GOSUB close3
  492.   ERASE sx,sy
  493.   DIM sx(4,ss),sy(4,ss)
  494. END IF
  495. RETURN
  496.  
  497. info:
  498. GOSUB open3
  499. COLOR 1,0
  500. PRINT "Light 1.0"
  501. PRINT "By Ronald S. Hill"
  502. PRINT
  503.  
  504. PRINT "If you like this"
  505. PRINT "program please send"
  506. PRINT "$00.00 and a nice"
  507. PRINT "message to Compuserve"
  508. PRINT "72777,2110. Thanks"
  509. GOSUB in
  510. GOSUB close3
  511. RETURN
  512.  
  513. bounce:
  514. IF bo=-1 THEN
  515.   bo=0
  516.   MENU 2,3,1,"  Bounce"
  517. ELSE
  518.   bo = -1
  519.   MENU 2,3,1,"> Bounce"
  520. END IF
  521. RETURN
  522.  
  523. pla:
  524. IF m1=1 THEN GOSUB dev
  525. IF m1=2 THEN GOSUB score
  526. IF m1=3 THEN GOSUB snake
  527. RETURN
  528.  
  529. dev:
  530. mt=pn
  531. pn=m0-2
  532. GOSUB open3
  533. GOSUB device
  534. GOSUB close3
  535. pn=mt
  536. RETURN
  537.  
  538. device:
  539.  
  540. COLOR pc(pn),0
  541. CLS
  542. PRINT "Player ";pn
  543. PRINT
  544. FOR x=1 TO 7
  545. IF dn$(x)<>"" THEN PRINT x;" - ";dn$(x)
  546. NEXT x
  547. IF pn<>1 OR np<>0 THEN PRINT "<space>- Continue"
  548. PRINT
  549. PRINT "Choose Your Weapon:"
  550. ins: GOSUB in
  551. I = VAL(I$)
  552. IF I$<>" " THEN pd(pn)=I
  553. IF (I=0 AND I$<>" ") OR I>8 THEN GOTO ins
  554. IF I>0 AND I<4 THEN
  555.   PRINT "Enter Name"
  556.   LINE INPUT ":";pn$(pn)
  557. END IF
  558.  
  559. IF pn$(pn)="" AND I>0 AND I<8 THEN pn$(pn)=dn$(pd(pn))
  560. RETURN
  561.  
  562.  
  563. score:
  564. mt=m0-2
  565. GOSUB open3
  566. COLOR pc(mt),0
  567. CLS
  568. PRINT
  569. PRINT "Player"mt
  570. PRINT "Current score is"sc(mt)
  571. INPUT "New score:",ts
  572. IF ts<>0 THEN ps(mt)=ts
  573. GOSUB close3
  574. RETURN
  575.  
  576.  
  577. snake:
  578. IF so=0 THEN BEEP: RETURN
  579. mt=m0-2
  580. IF sa(mt) THEN
  581.   sa(mt)=0
  582.   ss(mt)=0
  583.   IF sa(1)+sa(2)+sa(3)+sa(4)=0 THEN
  584.     sa=0
  585.     MENU 2,2,1,"  Snakes"
  586.   END IF
  587.   MENU 2+mt,3,1,"  Snake"
  588. ELSE
  589.   GOSUB open3
  590.   COLOR 1,0
  591.   CLS
  592.   sa(mt)=-1
  593.   PRINT
  594.   PRINT "This option sets or"
  595.   PRINT "clears one player"
  596.   PRINT "as a snake."
  597.   PRINT
  598.   PRINT "Player"mt
  599.   PRINT "Default is 200"
  600.   INPUT "size of snake:",ss(mt)
  601.   IF ss(mt)=0 THEN ss(mt)=200
  602.   IF ss(mt)>ss THEN
  603.     ss=ss(mt)
  604.     ERASE sx,sy
  605.     DIM sx(4,ss),sy(4,ss)
  606.   END IF
  607.   IF sa=0 THEN
  608.     sa=-1
  609.     MENU 2,2,1,"> Snakes"
  610.   END IF
  611.   MENU 2+mt,3,1,"> Snake"
  612.   GOSUB close3
  613. END IF
  614. RETURN
  615.  
  616. open3:
  617. 'MENU OFF
  618. WINDOW 3,,(40,30)-(250,130),1+2 ,1
  619. RETURN
  620.  
  621. close3:
  622. 'MENU ON
  623. WINDOW CLOSE 3
  624. RETURN
  625.  
  626. smenuon:
  627. so=-1
  628. RETURN
  629.  
  630. smenuoff:
  631. so=0
  632. RETURN
  633.  
  634. abort:
  635. RETURN
  636.